home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / schemeMode.tcl < prev    next >
Encoding:
Text File  |  1997-10-08  |  5.9 KB  |  140 lines  |  [TEXT/ALFA]
  1.  
  2. alpha::mode Scm 1.0 dummyScm {*.scm} {}
  3.  
  4. #================================================================================
  5. # Scheme mode definition !  oleg@ponder.csci.unt.edu (Oleg Kiselyov)
  6. #
  7. # $Id: SchemeMode.tcl,v 1.3 1996/07/03 14:19:49 oleg Exp oleg $
  8. #================================================================================
  9. #newPref f elecRBrace {1} Scm
  10. newPref v leftFillColumn {2} Scm
  11. newPref v prefixString {;; } Scm 
  12. #newPref f electricSemi {1} Scm
  13. newPref v wordBreak {[^\(\) \t\r\n]+} Scm
  14. #newPref f elecLBrace {1} Scm
  15. newPref f wordWrap {0} Scm
  16. newPref v funcExpr {^[\(]define.*$} Scm
  17. #newPref v funcExpr {^[^ \t\(\r/].*\(.*\)$} Scm
  18. newPref v wordBreakPreface {[\(\) \t\r\n]} Scm
  19. #newPref v wordBreakPreface {([^a-zA-Z0-9_])} Scm
  20. # newPref f optionIsMeta {1} Scm
  21. newPref f electricTab {1} Scm
  22. newPref f autoMark 0 Scm
  23.  
  24. set scmCommentRegexp    {;.*$}
  25. set scmPreRegexp                {^\#[\t ]*[a-z]*}
  26. set schemeKeyWords              {
  27.     declare define define-macro lambda let let* letrec begin cond case do else
  28.     delay and or if set! #t #f
  29.     not eqv? eq? equal? pair? cons car cdr set-car! set-cdr!
  30.     caar cadr cdar cddr null? list? list length
  31.     append reverse list-ref memq memv member assq assv assoc
  32.     = < > <= >= zero? positive? negative? odd?
  33.     even? + * - / abs
  34.     exact->inexact inexact->exact number->string
  35.     string->number char? 
  36.     string string-length string-ref string-set! string=?
  37.     substring string-append vector?
  38.     make-vector vector vector-length vector-ref vector-set! procedure?
  39.     apply map for-each call-with-current-continuation
  40.     eof-object? read-char peek-char
  41.         }
  42. #regModeKeywords -e {;} -c cyan -k blue Scm $schemeKeyWords -i ")" -i "("  -i "," -i "." -I red
  43. regModeKeywords -e {;} -c cyan -k blue -s green Scm $schemeKeyWords
  44.  
  45.  
  46. #================================================================================
  47.  
  48. proc dummyScm {} {}
  49.  
  50. proc Scm::MarkFile {} {
  51.   set pat1 {^[ \t]*[\(][#a-zA-z]*(define|define-[a-zA-Z]+) +[\(]*([^\(\) \t\r\n]+)}
  52.   set end [maxPos]
  53.   set pos 0
  54.   set l {}
  55.   while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
  56.     regexp -nocase $pat1 [eval getText $mtch] allofit defunname name
  57.     set start [lindex $mtch 0]
  58.     set end [nextLineStart $start]
  59.     set pos $end
  60.     set inds($name) [lineStart [expr $start - 1]]
  61.   }
  62.  
  63.   if {[info exists inds]} {
  64.     foreach f [lsort -ignore [array names inds]] {
  65.       set next [nextLineStart $inds($f)]
  66.       setNamedMark $f $inds($f) $next $next
  67.     }
  68.   }
  69. }
  70.  
  71. #================================================================================
  72. #                                       Indenting a line of a Scheme code
  73. #
  74. # The idea is simple: the indent of a new line is the same as the indent of the
  75. # previous non-empty non-comment-only line *plus* the paren balance of that
  76. # line times two
  77. # That is, if the last code line was paren balanced, the next line would have
  78. # the same indent. If the prev line opened an expression but didn't close it,
  79. # the new line would be indented further
  80. #
  81. # See indentLine.tcl for more details
  82.  
  83. proc Scm::indentLine {} {
  84.         set beg [lineStart [getPos]]
  85.         set end [nextLineStart [getPos]]
  86.  
  87.         # Find last previous non-comment line and get its leading whitespace
  88.         set pos $beg
  89.         set lst [search -s -f 0 -r 1 -i 0 {^[ \t]*[^ ;\t\r\n]} [expr $pos-1]]   
  90.         set line [getText [lindex $lst 0] [expr [nextLineStart [lindex $lst 0]] - 1]]
  91.         set lwhite [getText [lindex $lst 0] [expr [lindex $lst 1] - 1]]
  92.  
  93.         # computing the balance of parentheses within the 'line'
  94.         # This appears to be utterly elementary. One has to keep in mind however
  95.         # that parentheses might appear in comments and/or quoted strings,
  96.         # in which case they shouldn't count. Although it's easy to detect a
  97.         # Scheme comment by a semicolon, a semicolon can also appear within
  98.         # a quoted string. Note that a double quote isn't that sure a sign of
  99.         # a quoted string: the double quote may be escaped. And the backslash
  100.         # can be escaped in turn... Thus we face a full-blown problem of parsing
  101.         # a string according to a context-free grammar.
  102.         # We note however that a TCL interpretor does similar kind of parsing
  103.         # all the time. So, we can piggy-back on it and have it decide what is
  104.         # the quoted string and when a semicolon really starts a comment. To this
  105.         # end, we replace all non-essential characters from the 'line' with spaces,
  106.         # separate all parens with spaces (so each paren would register as a
  107.         # separate token with the TCL interpretor), replace a semicolon with
  108.         # an opening brace (which, if unescaped and unquoted, acts as some kind
  109.         # of "comment", that is, shields all symbols that follows).
  110.         # After that, we get TCL interpretor to convert thus prepared 'line'
  111.         # into a list, and simply count the balance of '(' and ')' tokens.
  112.         
  113.         regsub -all -nocase {[^ ();\"\\]} $line { } line1
  114.         regsub -all {;} $line1 "\{" line
  115.         regsub -all {[()]} $line { \0 } line1
  116.         set line_list [eval "list $line1 \}"]
  117.         #alertnote ">$line_list<"
  118.         set balance 0
  119.         foreach i $line_list { switch $i ( {incr balance} ) {incr balance -1} }
  120.         #alertnote "balance $balance, lwhite [string length $lwhite]"
  121.         if {$balance < 0} {
  122.                 set lwhite [string range $lwhite 0 [expr [string length $lwhite] + 2 * $balance - 1]]
  123.         } else {
  124.                 append lwhite [string range "              " 1 [expr 2 * $balance]]
  125.         }
  126.         #alertnote "new lwhite [string length $lwhite]"
  127.                         
  128.         set text [getText $beg [nextLineStart $beg]]
  129.         regexp {^[ \t]*} $text white
  130.         set len [string length $white]
  131.         
  132.         if {$white != $lwhite} {
  133.                 replaceText $beg [expr $beg + $len] $lwhite
  134.         }
  135.         goto [expr $beg + [string length $lwhite]]
  136.         return
  137.         
  138. }
  139.  
  140.